Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part08

Text File | 1987-08-01 | 56.7 KB | 1,465 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i082:  Common Objects, Common Loops, Common Lisp, Part08/13
Message-ID: <[e-mail]>
Date: 3 Aug 87 03:02:26 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 1454
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 82
Archive-name: comobj.lisp/Part08

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 8 (of 13)."
# Contents:  class-prot.l low.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'class-prot.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'class-prot.l'\"
else
echo shar: Extracting \"'class-prot.l'\" \(26632 characters\)
sed "s/^X//" >'class-prot.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X;;;
X;;; ADD-NAMED-CLASS  proto-class name local-supers local-slot-slotds extra
X;;; protocol: class-definition
X;;;
X;;; Creates or updates the definition of a class with a named class.  If
X;;; there is already a class named name, calls class-for-redefinition to
X;;; find out which class to use for the redefinition.  Once it has a class
X;;; object to use it stores the relevant information from the ds-options in
X;;; the class and calls add-class to add the class to the class
X;;; lattice.
X;;;
X(defmeth add-named-class ((proto-class basic-class) name
X                            local-supers
X                            local-slot-slotds
X                            extra)
X  ;; First find out if there is already a class with this name.
X  ;; If there is, call class-for-redefinition to get the class
X  ;; object to use for the new definition.  If there is no exisiting
X  ;; class we just make a new instance.
X  (let* ((existing (class-named name t))
X     (class (if existing
X            (class-for-redefinition existing proto-class name
X                        local-supers local-slot-slotds
X                        extra)
X            (make (class-of proto-class)))))
X
X    (setq local-supers
X      (mapcar
X        #'(lambda (ls)
X        (or (class-named ls t)
X            (error "~S was specified as the name of a local-super~%~
X                            for the class named ~S.  But there is no class~%~
X                            class named ~S." ls name ls)))
X        local-supers))
X
X    (setf (class-name class) name)
X    (setf (class-ds-options class) extra)    ;This is NOT part of the
X                        ;standard protocol.
X
X    (add-class class local-supers local-slot-slotds extra)
X
X    (setf (class-named name) class)
X    name))
X
X(defmeth add-class
X     ((class essential-class) new-local-supers new-local-slots extra)
X  (ignore extra)
X  (let ((old-local-supers (class-local-supers class))
X    (old-local-slots (class-local-slots class)))
X
X    (setf (class-local-supers class) new-local-supers)
X    (setf (class-local-slots class) new-local-slots)
X
X    (if (and old-local-supers            ;*** YUCH!! There is a bug
X         new-local-supers            ;*** when old and new are ()
X         (equal old-local-supers new-local-supers))
X    (if (and old-local-slots
X         new-local-slots
X         (equal old-local-slots new-local-slots))
X        ;; If the supers haven't changed, and the slots haven't changed
X        ;; then not much has changed and we don't have to do anything.
X        ()
X        ;; If only the slots have changed call slots-changed.
X        (slots-changed class old-local-slots extra t))
X    ;; If the supers have changed, first update local-supers and
X    ;; direct-subclasses of all the people involved.  Then call
X    ;; supers-changed.
X    (progn
X      (dolist (nls new-local-supers)
X        (unless (memq nls old-local-supers)
X          (check-super-metaclass-compatibility class nls)
X          (push class (class-direct-subclasses nls))))
X      (dolist (ols old-local-supers)
X        (unless (memq ols new-local-supers)
X          (setf (class-direct-subclasses ols)
X            (delq class (class-direct-subclasses ols)))))
X      (supers-changed class old-local-supers old-local-slots extra t)))))
X
X
X(defmeth supers-changed ((class basic-class)
X             old-local-supers
X             old-local-slots
X             extra
X             top-p)
X  (ignore old-local-slots)
X  (let ((cpl (compute-class-precedence-list class)))
X    (setf (class-class-precedence-list class) cpl)
X    (update-slots--class class cpl)                 ;This is NOT part of
X                                 ;the essential-class
X                                 ;protocol.
X    (dolist (sub-class (class-direct-subclasses class))
X      (supers-changed sub-class
X              (class-local-supers sub-class)
X              (class-local-slots sub-class)
X              extra
X              nil))
X    (when top-p                                          ;This is NOT part of
X      (update-method-inheritance class old-local-supers));the essential-class
X                                 ;protocol.
X    ))
X
X(defmeth slots-changed ((class basic-class)
X            old-local-slots
X            extra
X            top-p)
X  (ignore top-p old-local-slots)
X  ;; When this is called, class should have its local-supers and
X  ;; local-slots slots filled in properly.
X  (update-slots--class class (class-class-precedence-list class))
X  (dolist (sub-class (class-direct-subclasses class))
X    (slots-changed sub-class (class-local-slots sub-class) extra nil)))
X
X(defun update-slots--class (class cpl)
X  (let ((obsolete-class nil))
X    (multiple-value-bind (instance-slots non-instance-slots)
X    (collect-slotds class (class-local-slots class) cpl)
X      ;; If there is a change in the shape of the instances then the
X      ;; old class is now obsolete.  Make a copy of it, then fill
X      ;; ourselves in properly and obsolete it.
X      (when (and (class-has-instances-p class)
X         (not (same-shape-slots-p (class-instance-slots class)
X                      instance-slots)))
X    (setq obsolete-class (copy-class class)))
X      (setf (class-no-of-instance-slots class) (length instance-slots))
X      (setf (class-instance-slots class) instance-slots)
X      (setf (class-non-instance-slots class) non-instance-slots)
X      (when obsolete-class
X    (flush-class-caches class)
X    (make-class-obsolete class (copy-class class))))))
X
X;;;
X;;; CLASS-FOR-REDEFINITION old-class proto-class name ds-options slotds
X;;; protocol: class definition
X;;;
X;;; When a class is being defined, and a class with that name already exists
X;;; a decision must be made as to what to use for the new class object, and
X;;; whether to update the old class object.  For this, class-for-redefinition
X;;; is called with the old class object, the prototype of the new class, and
X;;; the name ds-options and slotds corresponding to the new definition.
X;;; It should return the class object to use as the new definition.  It is
X;;; OK for this to be old-class if that is appropriate.
X;;;
X(defmeth class-for-redefinition ((old-class essential-class)
X                 proto-class
X                 name
X                 local-supers
X                 local-slot-slotds
X                 extra)
X  (ignore local-supers local-slot-slotds extra)
X  (cond ((not (compatible-meta-class-change-p old-class proto-class))
X     (error "The class ~A already exists; its class is ~A.~%~
X         The :class argument in the defstruct is ~A.
X         This is an incompatible meta-class change.~%"
X        name
X        (class-name (class-of old-class))
X        (class-name (class-of proto-class))))
X    (t (values old-class (copy-class old-class)))))
X
X(defmeth update-method-inheritance ((class basic-class) old-local-supers)
X  ;; In the absence of method combination, we have to flush all the
X  ;; discriminators which we used to inherit and all the discriminators
X  ;; which we now inherit.
X  (let ((old-mil
X      (compute-method-inheritance-list class old-local-supers))
X    (new-mil
X      (compute-method-inheritance-list class
X                       (class-local-supers class)))
X    (discriminators ())
X    (combined-discriminators ()))
X    (dolist (old-donor old-mil)
X      (when (setq discriminators (class-direct-discriminators old-donor))
X    (dolist (old-discriminator discriminators)
X      (flush-discriminator-caches old-discriminator)
X      (when (methods-combine-p old-discriminator)
X        (pushnew old-discriminator combined-discriminators)))))
X    (dolist (new-donor new-mil)
X      (when (setq discriminators (class-direct-discriminators new-donor))
X    (unless (memq new-donor old-mil)
X      (dolist (new-discriminator discriminators)
X        (when (methods-combine-p new-discriminator)
X          (pushnew new-discriminator combined-discriminators))
X        (flush-discriminator-caches new-discriminator)))))
X    (when (fboundp 'combine-methods)                 ;***
X      (COMBINE-METHODS CLASS COMBINED-DISCRIMINATORS)))) ;***
X
X
X(defmeth discriminator-changed ((discriminator essential-discriminator)
X                method
X                added-p)
X  (ignore method added-p)
X  (make-discriminating-function discriminator)
X  (flush-discriminator-caches discriminator))
X
X
X(defun make-class-obsolete (class obsolete-class)
X  (setf (class-wrapper-class (class-wrapper obsolete-class)) obsolete-class)
X  (setf (class-wrapper class) nil)
X  (setf (class-local-supers obsolete-class) (list class))
X  (setf (class-class-precedence-list obsolete-class)
X        (cons obsolete-class (class-class-precedence-list class)))
X  (setf (class-name obsolete-class)
X    (symbol-append "obsolete-" (class-name class)))
X  (setf (iwmc-class-class-wrapper obsolete-class)
X        (wrapper-of (class-named 'obsolete-class)))
X  obsolete-class)
X
X(defun copy-class (class)
X  (let* ((no-of-instance-slots (class-no-of-instance-slots (class-of class)))
X         (new-class (%allocate-instance--class no-of-instance-slots)))
X    (setf (iwmc-class-class-wrapper new-class)
X      (iwmc-class-class-wrapper class))
X    (iterate ((i from 0 below no-of-instance-slots))
X      (let ((index (%convert-slotd-position-to-slot-index i)))
X    (setf (get-static-slot--class new-class index)
X          (get-static-slot--class class index))))
X    (setf (iwmc-class-dynamic-slots new-class)
X          (copy-list (iwmc-class-dynamic-slots class)))
X    new-class))
X
X(defun wrapper-of (class)
X  (or (class-wrapper class)
X      (setf (class-wrapper class) (make-class-wrapper class))))
X
X(defmeth collect-slotds ((class basic-class) local-slots cpl)
X  (let ((slots ()))
X    (flet ((add-slotd (slotd)
X         (let ((entry
X             (or (assq (slotd-name slotd) slots)
X             (progn (push (list (slotd-name slotd)) slots)
X                (car slots)))))
X           (push slotd (cdr entry)))))
X      (dolist (super (reverse (cdr cpl)))    ;fix this consing later
X    (dolist (super-slotd (class-local-slots super))
X      (add-slotd super-slotd)))
X
X      (dolist (local-slotd local-slots)
X    (add-slotd local-slotd)))
X
X    ;; Now use compute-effective-slotd to condense all the
X    ;; inherited slotds into the one effective slotd.
X    (dolist (slot slots)
X      (setf (car slot)
X        (compute-effective-slotd class (cdr slot))))
X    ;; Now we need to separate it back out into instance and non-instance
X    ;; slots.
X    (let ((instance ())
X      (non-instance ()))
X      (dolist (slot slots)
X    (setq slot (car slot))
X    (if (eq (slotd-allocation slot) ':instance)
X        (push slot instance)
X        (push slot non-instance)))
X      (values instance non-instance slots))))
X
X(defmethod compute-effective-slotd ((class class) slotds)
X  (ignore class)
X  (let ((slotd  (if (null (cdr slotds))
X            (car slotds)
X            (copy-slotd (car slotds)))))
X    (flet ((merge-values (default type read-only accessor allocation)
X         (macrolet ((merge-value (name value)
X              `(when (eq (,name slotd) *slotd-unsupplied*)
X                 (setf (,name slotd) ,value))))
X           (merge-value slotd-default default)
X           (merge-value slotd-type type)
X           (merge-value slotd-read-only read-only)
X           (merge-value slotd-accessor accessor)
X           (merge-value slotd-allocation allocation))))
X      (dolist (s (cdr slotds))
X    (merge-values (slotd-default s)
X              (slotd-type s)
X              (slotd-read-only s)
X              (slotd-accessor s)
X              (slotd-allocation s)))
X      (merge-values 'nil      ;default value -- for now
X            't        ;type
X            'nil      ;read-only
X            'nil      ;accessor
X          :instance)) ;allocation
X    slotd))
X
X(defmethod compute-class-precedence-list ((root class))
X  #+Lucid (declare (optimize (speed 0) (safety 3)))
X  (let ((*cpl* ())
X    (*root* root)
X    (*must-precede-alist* ()))
X    (declare (special *cpl* *root* *must-precede-alist*))
X    ;; We start by computing two values.
X    ;;   CPL
X    ;;     The depth-first left-to-right up to joins walk of the supers tree.
X    ;;     This is equivalent to breadth-first left-to-right walk of the
X    ;;     tree with all but the last occurence of a class removed from
X    ;;     the resulting list.  This is in fact how the walk is implemented.
X    ;;
X    ;;   MUST-PRECEDE-ALIST
X    ;;     An alist of the must-precede relations. The car of each element
X    ;;     of the must-precede-alist is a class, the cdr is all the classes
X    ;;     which either:
X    ;;       have this class as a local super
X    ;;      or
X    ;;       appear before this class in some other class's local-supers.
X    ;;
X    ;;     Thus, the must-precede-alist reflects the two constraints that:
X    ;;       1. A class must appear in the CPL before its local supers.
X    ;;       2. Order of local supers is preserved in the CPL.
X    ;;
X    (labels
X   ;(flet
X       (
X;    (walk-supers (class &optional precedence)
X;      (let ((elem (assq class must-precede-alist)))
X;        (if elem
X;        (setf (cdr elem) (union (cdr elem) precedence))
X;        (push (cons class precedence) must-precede-alist)))
X;      (let ((rsupers (reverse (cons class (class-local-supers class)))))
X;        (iterate ((sup in rsupers)
X;              (pre on (cdr rsupers))
X;              (temp = nil))
X;          ;; Make sure this element of supers is OK.
X;          ;;  Actually, there is an important design decision hidden in
X;          ;;  here.  Namely, at what time should symbols in a class's
X;          ;;  local-supers be changed to the class objects they are
X;          ;;  forward referencing.
X;          ;;   1. At first make-instance (compute-class-precedence-list)?
X;          ;;   2. When the forward referenced class is first defined?
X;          ;;  This code does #1.
X;          (cond ((classp sup))
X;            ((and (symbolp sup)
X;              (setq temp (class-named sup t)))
X;             ;; This is a forward reference to a class which is
X;             ;; now defined.  Replace the symbol in the local
X;             ;; supers with the actual class object, and set sup.
X;             (nsubst temp sup (class-local-supers class))
X;             (setq sup temp))
X;            ((symbolp sup)
X;             (error "While computing the class-precedence-list for ~
X;                             the class ~S.~%~
X;                             The class ~S (from the local supers of ~S) ~
X;                             is undefined."
X;                (class-name root) sup (class-name class)))
X;            (t
X;             (error "INTERNAL ERROR --~%~
X;                             While computing the class-precedence-list for ~
X;                             the class ~S,~%~
X;                             ~S appeared in the local supers of ~S."
X;                root sup class)))
X;          (walk-supers sup pre))
X;        (unless (memq class cpl) (push class cpl))))
X    (must-move-p (element list &aux move)
X      (dolist (must-precede (cdr (assq element *must-precede-alist*)))
X        (when (setq move (memq must-precede (cdr list)))
X          (return move))))
X    (find-farthest-move (element move)
X      (let ((closure (compute-must-precedes-closure element)))
X        (dolist (must-precede closure)
X          (setq move (or (memq must-precede move) move)))
X        move))
X    (compute-must-precedes-closure (class)
X      (let ((closure ()))
X        (labels ((walk (element path)
X               (when (memq element path)
X             (class-ordering-error
X               *root* element path *must-precede-alist*))
X               (dolist (precede
X                 (cdr (assq element
X                        *must-precede-alist*)))
X             (unless (memq precede closure)
X               (pushnew precede closure)
X               (walk precede (cons element path))))))
X          (walk class nil)
X          closure))))
X
X      (walk-supers *root*)            ;Do the walk
X      ;; For each class in the cpl, make sure that there are no classes after
X      ;; it which should be before it.  We do this by cdring down the list,
X      ;; making sure that for each element of the list, none of its
X      ;; must-precedes come after it in the list. If we find one, we use the
X      ;; transitive closure of the must-precedes (call find-farthest-move) to
X      ;; see where the class must really be moved. We use a hand-coded loop
X      ;; so that we can splice things in and out of the CPL as we go.
X      (let ((tail *cpl*)
X        (element nil)
X        (move nil))
X    (loop (when (null tail) (return))
X          (setq element (car tail)
X            move (must-move-p element tail))
X          (cond (move
X             (setq move (find-farthest-move element move))
X             (setf (cdr move) (cons element (cdr move)))
X             (setf (car tail) (cadr tail)) ;Interlisp delete is OK
X             (setf (cdr tail) (cddr tail)) ;since it will never be
X                           ;last element of list.
X             )
X            (t
X             (setq tail (cdr tail)))))
X    (copy-list *cpl*)))))
X
X(defun walk-supers (class &optional precedence)
X  (declare (special *cpl* *root* *must-precede-alist*))
X  (let ((elem (assq class *must-precede-alist*)))
X    (if elem
X    (setf (cdr elem) (union (cdr elem) precedence))
X    (push (cons class precedence) *must-precede-alist*)))
X  (let ((rsupers (reverse (cons class (class-local-supers class)))))
X    (iterate ((sup in rsupers)
X          (pre on (cdr rsupers))
X          (temp = nil))
X      ;; Make sure this element of supers is OK.
X      ;;  Actually, there is an important design decision hidden in
X      ;;  here.  Namely, at what time should symbols in a class's
X      ;;  local-supers be changed to the class objects they are
X      ;;  forward referencing.
X      ;;   1. At first make-instance (compute-class-precedence-list)?
X      ;;   2. When the forward referenced class is first defined?
X      ;;  This code does #1.
X      (cond ((classp sup))
X        ((and (symbolp sup)
X          (setq temp (class-named sup t)))
X         ;; This is a forward reference to a class which is
X         ;; now defined.  Replace the symbol in the local
X         ;; supers with the actual class object, and set sup.
X         (nsubst temp sup (class-local-supers class))
X         (setq sup temp))
X        ((symbolp sup)
X         (error "While computing the class-precedence-list for ~
X                             the class ~S.~%~
X                             The class ~S (from the local supers of ~S) ~
X                             is undefined."
X            (class-name *root*) sup (class-name class)))
X        (t
X         (error "INTERNAL ERROR --~%~
X                             While computing the class-precedence-list for ~
X                             the class ~S,~%~
X                             ~S appeared in the local supers of ~S."
X            *root* sup class)))
X      (walk-supers sup pre))
X    (unless (memq class *cpl*) (push class *cpl*))))
X
X(defun class-ordering-error (root element path must-precede-alist)
X  (ignore root)
X  (setq path (cons element (reverse (memq element (reverse path)))))
X  (flet ((pretty (class) (or (class-name class) class)))
X    (let ((explanations ()))
X      (do ((tail path (cdr tail)))
X      ((null (cdr tail)))
X    (let ((after (cadr tail))
X          (before (car tail)))
X      (if (memq after (class-local-supers before))
X          (push (format nil
X                "~% ~A must precede ~A -- ~
X                              ~A is in the local supers of ~A."
X                (pretty before) (pretty after)
X                (pretty after) (pretty before))
X            explanations)
X          (dolist (common-precede
X            (intersection
X              (cdr (assq after must-precede-alist))
X              (cdr (assq before must-precede-alist))))
X        (when (memq after (memq before
X                    (class-local-supers common-precede)))
X          (push (format nil
X                "~% ~A must precede ~A -- ~
X                                  ~A has local supers ~S."
X                (pretty before) (pretty after)
X                (pretty common-precede)
X                (mapcar #'pretty
X                    (class-local-supers common-precede)))
X            explanations))))))
X      (error "While computing the class-precedence-list for the class ~A:~%~
X              There is a circular constraint through the classes:~{ ~A~}.~%~
X              This arises because:~{~A~}"
X         (pretty root)
X         (mapcar #'pretty path)
X         (reverse explanations)))))
X
X(defmeth compute-method-inheritance-list ((class essential-class)
X                      local-supers)
X  (compute-class-precedence-list class))
X
X(defmeth compatible-meta-class-change-p (class proto-new-class)
X  (eq (class-of class) (class-of proto-new-class)))
X
X(defmeth check-super-metaclass-compatibility (class new-super)
X  (unless (eq (class-of class) (class-of new-super))
X    (error "The class ~S was specified as a~%super-class of the class ~S;~%~
X            but the meta-classes ~S and~%~S are incompatible."
X       new-super class (class-of new-super) (class-of class))))
X
X(defun classp (x)
X  (and (iwmc-class-p x) (typep--class x 'essential-class)))
X
X
X
X(defmeth class-standard-constructor ((class basic-class))
X  (dolist (constructor (ds-options-constructors (class-ds-options class)))
X    (when (null (cdr constructor)) (return (car constructor)))))
X
X
X(defmeth flush-class-caches ((class basic-class))
X  (let ((wrapper (class-wrapper class)))
X    (and wrapper (flush-class-wrapper-cache wrapper))
X    (iterate ((subclass in (class-direct-subclasses class)))
X      (flush-class-caches subclass))))
X
X
X  ;;
X;;;;;; CHANGE-CLASS
X  ;;
X
X(defun change-class (object new-class)
X  (or (classp new-class)
X      (setq new-class (class-named new-class)))
X  (let ((new-object (make new-class)))
X    ;; Call change-class-internal so that a user-defined method
X    ;; (or the default method) can copy the information from the
X    ;; old instance to the dummy instance of the new class.
X    (change-class-internal object new-object)
X    ;; Now that the dummy new-object has the right information,
X    ;; move all that stuff into the old-instance.
X    (setf (iwmc-class-class-wrapper object)
X      (wrapper-of new-class))
X    (setf (iwmc-class-static-slots object)
X      (iwmc-class-static-slots new-object))
X    (setf (iwmc-class-dynamic-slots object)
X      (iwmc-class-dynamic-slots new-object))
X    object))
X
X(defmeth change-class-internal ((old object) (new object))
X  (let ((all-slots (all-slots old)))
X    (iterate ((name in all-slots by cddr)
X              (value in (cdr all-slots) by cddr))
X      (put-slot-always new name value))))
X
X  ;;
X;;;;;; WITH-SLOTS
X  ;;
X
X(define-method-body-macro with-slots (instance-forms-and-options
X                       &body body
X                       &environment env)
X  :global (expand-with-slots nil nil instance-forms-and-options env body)
X  :method (expand-with-slots (macroexpand-time-generic-function
X                   macroexpand-time-environment)
X                 (macroexpand-time-method
X                   macroexpand-time-environment)
X                 instance-forms-and-options
X                 env
X                 body))
X
X(defun expand-with-slots (proto-discriminator proto-method first-arg env body)
X  (ignore proto-discriminator)
X  (setq first-arg (iterate ((arg in first-arg))
X            (collect (if (listp arg) arg (list arg)))))
X  (let ((entries (expand-with-make-entries proto-method first-arg))
X    (gensyms ()))
X    (dolist (arg first-arg)
X      (push (list (if (listp arg) (car arg) arg)
X          (gensym))
X        gensyms))
X    `(let ,(mapcar #'reverse gensyms)
X       ,(walk-form (cons 'progn body)
X      :environment env
X      :walk-function
X      #'(lambda (form context &aux temp)
X          (cond ((and (symbolp form)
X              (eq context ':eval)
X              (null (variable-lexical-p form))
X              (null (variable-special-p form))
X              (setq temp (assq form entries)))
X             (if (car (cddddr temp))    ;use slot-value?
X             (let ((get-slot
X                 `(get-slot ,(cadr (assq (cadr temp) gensyms))
X                        ',(slotd-name (cadddr temp)))))
X               (optimize-get-slot (caddr temp)
X                          get-slot))
X             `(,(slotd-accessor (cadddr temp))
X               ,(cadr (assq (cadr temp) gensyms)))))
X            ((and (listp form)
X              (or (eq (car form) 'setq)
X                  (eq (car form) 'setf)))
X             (cond ((cdddr form)
X                (cons 'progn
X                  (iterate ((pair on (cdr form) by cddr))
X                    (collect (list (car form)
X                           (car pair)
X                           (cadr pair))))))
X               ((setq temp (assq (cadr form) entries))
X                (if (car (cddddr temp))
X                (let ((get-slot
X                    `(setf-of-get-slot
X                       ,(cadr (assq (cadr temp) gensyms))
X                       ',(slotd-name (cadddr temp))
X                       ,(caddr form))))
X                  (optimize-setf-of-get-slot (caddr temp)
X                                 get-slot))
X                `(setf (,(slotd-accessor (cadddr temp))
X                    ,(cadr (assq (cadr temp) gensyms)))
X                       ,(caddr form))))
X               (t form)))
X            (t form)))))))
X
X;;; Returns an alist of the form:
X;;;
X;;;   (<prefix+slot-name> <instance-form> <class> <slotd> <use-slot-value-p>)
X;;;
X(defmeth expand-with-make-entries (method first-arg)
X  (let* ((entries ())
X         (method-arguments
X       (when (method-p method)
X         (iterate ((arg in (method-arglist method))
X               (spec in (method-type-specifiers method)))
X           (when (classp spec) (collect (cons arg spec)))))))
X    (iterate ((instance-and-keys in first-arg))
X      (keyword-bind ((use-slot-value nil)
X             (class nil class-specified-p)
X             (prefix nil prefix-specified-p))
X            (cdr instance-and-keys)
X    (let ((instance (car instance-and-keys)))
X      (setq class
X        (or (and class-specified-p
X             (or (class-named class t)
X                 (error "In WITH-SLOTS the class specified for ~
X                                     ~S, ~S ~%~
X                                     is not the name of a defined class."
X                    instance class)))
X            (cdr (assq instance method-arguments))
X            (error "The class of (the value of) ~S was not given in ~
X                           in the call to with-slots and could not be ~
X                           inferred automatically."
X              instance)))
X      (iterate ((slotd in (class-slots class)))
X        (push (list (if (null prefix-specified-p)
X                (slotd-name slotd)
X                (intern (string-append prefix
X                           (slotd-name slotd))
X                    (symbol-package
X                      (if (symbolp prefix)
X                      prefix
X                      (slotd-name slotd)))))
X            instance
X            class
X            slotd
X            use-slot-value)
X          entries)))))
X    entries))
X
X
X(defun named-object-print-function (instance stream depth
X                         &optional (extra nil extra-p))
X  (ignore depth)
X  (printing-random-thing (instance stream)
X    ;; I know I don't have to do this this way.  I know I
X    ;; could use ~[~;~], but how many Common Lisps do you
X    ;; think have that completely debugged?
X    (if extra-p
X    (format stream "~A ~S ~:S"
X        (capitalize-words (class-name (class-of instance)))
X        (get-slot instance 'name)
X        extra)
X    (format stream "~A ~S"
X        (capitalize-words (class-name (class-of instance)))
X        (get-slot instance 'name)))))
X
END_OF_FILE
if test 26632 -ne `wc -c <'class-prot.l'`; then
    echo shar: \"'class-prot.l'\" unpacked with wrong size!
fi
# end of 'class-prot.l'
fi
if test -f 'low.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'low.l'\"
else
echo shar: Extracting \"'low.l'\" \(27849 characters\)
sed "s/^X//" >'low.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER) 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; This file contains portable versions of low-level functions and macros
X;;; which are ripe for implementation specific customization.  None of the
X;;; code in this file *has* to be customized for a particular Common Lisp
X;;; implementation. Moreover, in some implementations it may not make any
X;;; sense to customize some of this code.
X;;;
X;;; But, experience suggests that MOST Common Lisp implementors will want
X;;; to customize some of the code in this file to make PCL run better in
X;;; their implementation.  The code in this file has been separated and
X;;; heavily commented to make that easier.
X;;;
X;;; Implementation-specific version of this file already exist for:
X;;;
X;;;    Symbolics 3600 family       3600-low.lisp
X;;;    Lucid Lisp                  lucid-low.lisp
X;;;    Xerox 1100 family           1100-low.lisp
X;;;    Ti Explorer                 ti-low.lisp
X;;;    Vaxlisp                     vaxl-low.lisp
X;;;    Spice Lisp                  spice-low.lisp
X;;;    Kyoto Common Lisp           kcl-low.lisp
X;;;    ExCL (Franz)                excl-low.lisp
X;;;    H.P. Common Lisp            hp-low.lisp
X;;;
X;;;
X;;; These implementation-specific files are loaded after this file.  Because
X;;; none of the macros defined by this file are used in functions defined by
X;;; this file the implementation-specific files can just contain the parts of
X;;; this file they want to change.  They don't have to copy this whole file
X;;; and then change the parts they want.
X;;;
X;;; If you make changes or improvements to these files, or if you need some
X;;; low-level part of PCL re-modularized to make it more portable to your
X;;; system please send mail to [e-mail].
X;;;
X;;; Thanks.
X;;;
X
X(in-package 'pcl)
X
X  ;;
X;;;;;; without-interrupts
X  ;;
X;;; OK, Common Lisp doesn't have this and for good reason.  But For all of
X;;; the Common Lisp's that PCL runs on today, there is a meaningful way to
X;;; implement this.  WHAT I MEAN IS:
X;;;
X;;; I want the body to be evaluated in such a way that no other code that is
X;;; running PCL can be run during that evaluation.  I agree that the body
X;;; won't take *long* to evaluate.  That is to say that I will only use
X;;; without interrupts around small computations.
X;;;
X;;; OK?
X;;;
X(defmacro without-interrupts (&body body)
X  `(progn ,.body))
X
X  ;;
X;;;;;; Load Time Eval
X  ;;
X;;;
X;;; #, is woefully inadequate.  You can't use it inside of a macro and have
X;;; the expansion of part of the macro be evaluated at load-time.
X;;;
X;;; load-time-eval is used to provide an interface to implementation
X;;; dependent implementation of load time evaluation.
X;;;
X;;; A compiled call to load-time-eval:
X;;;   should evaluated the form at load time,
X;;;   but if it is being compiled-to-core evaluate it at compile time
X;;; Interpreted calls to load-time-eval:
X;;;   should just evaluate form at run-time.
X;;;
X;;; The portable implementation just evaluates it every time, and PCL knows
X;;; this.  PCL is careful to only use load-time-eval in places where (except
X;;; for performance penalty) it is OK to evaluate the form every time.
X;;;
X(defmacro load-time-eval (form)
X  `(progn ,form))
X
X  ;;
X;;;;;; Memory Blocks (array-like blocks of memory)
X  ;;
X;;; The portable implementation of memory-blocks is as arrays.
X;;;
X;;; The area argument to make-memory-block is based on the area feature of
X;;; LispM's.  As it is used in PCL that argument will always be an unquoted
X;;; symbol.  So a call to make-memory-block will look like:
X;;;     (make-memory-block 100 class-wrapper-area)
X;;; This allows any particular implementation of make-memory-block to look at
X;;; the symbol at compile time (macroexpand time) and know where the memory-
X;;; block should be consed.  Currently the only values ever used as the area
X;;; argument are:
X;;;
X;;;    CLASS-WRAPPER-AREA        used when making a class-wrapper
X;;;
X;;; NOTE:
X;;;     It is perfectly legitimate for an implementation of make-memory-block
X;;;     to ignore the area argument.  It only exists to try to improve paging
X;;;     performance in systems which do allow control over where memory is
X;;;     allocated.
X;;;
X(defmacro make-memory-block (size &optional area)
X  (ignore area)
X  `(make-array ,size :initial-element nil))
X
X(defmacro memory-block-size (block)
X  `(array-dimension ,block 0))
X
X(defmacro memory-block-ref (block offset)
X  `(svref ,block ,offset))
X
X(eval-when (compile load eval)
X
X(defun make-memory-block-mask (size &optional (words-per-entry 2))
X  (logxor (1- (expt 2 (floor (log size 2))))
X      (1- (expt 2 (ceiling (log words-per-entry 2))))))
X
X)
X
X;;;
X;;; clear-memory-block sets all the slots of a memory block to nil starting
X;;; at start.  This really shouldn't be a macro, it should be a function.
X;;; It has to be a macro because otherwise its call to memory-block-ref will
X;;; get compiled before people get a chance to change memory-block-ref.
X;;; This argues one of:
X;;;  - this should be a function in another file.  No, it belongs here.
X;;;  - Common Lisp should have defsubst.  Probably
X;;;  - Implementors should take (proclaim '(inline xxx)) more seriously.
X;;;
X(defmacro clear-memory-block (block start &optional times)
X  (once-only (block)
X    `(do ((end ,(if times `(+ ,start ,times) `(length ,block)))
X      (index ,start (+ index 1)))
X     ((= index end))
X       (setf (memory-block-ref ,block index) nil))))
X
X  ;;
X;;;;;; CLASS-OF
X  ;;
X;;;
X;;; *class-of* is the lisp code for the definition of class-of.
X;;;
X;;; This version uses type-of to determine the class of an object.  Because
X;;; of the underspecification of type-of, this does not always produce the
X;;; "most specific class of which x is an instance".  But it is the best I
X;;; can do portably.
X;;;
X;;; Specific ports of PCL should feel free to redefine *class-of* to provide
X;;; a more accurate definition.  At some point in any definition of class-of
X;;; there should be a test to determine if the argument is a %instance, and
X;;; if so the %instance-class-of macro should be used to determine the class
X;;; of the instance.
X;;;
X;;; Whenever a new meta-class is defined, the portable code will take care of
X;;; modifying the definition of %instance-class-of and recompiling class-of.
X;;;
X(defvar *class-of*
X    '(lambda (x)
X       (or (and (%instancep x)
X            (%instance-class-of x))
X          ;(%funcallable-instance-p x)
X           (class-named (type-of x) t)
X           (error "Can't determine class of ~S" x))))
X
X(defvar *meta-classes* ())
X
X(defmacro %instance-class-of (arg)
X  `(cond ,@(iterate ((mc in *meta-classes*))
X         (collect
X           `((eq (%instance-meta-class ,arg)
X             ;; %^&$%& KCL has to have this stupid call to
X             ;; load-time-eval here because their compiler
X             ;; always creates a file and compiles that file.
X             #-KCL',(class-named (car mc))
X             #+KCL (load-time-eval (class-named ',(car mc))))
X         (funcall (function ,(cdr mc)) ,arg))))
X     (t
X      (error
X        "Internal error in %INSTANCE-CLASS-OF.  The argument to~%~
X             %instance-class-of is a %instance, but its meta-class is~%~
X             not one of the meta-classes defined with define-meta-class."
X        (%instance-meta-class ,arg)))))
X
X(defmacro define-meta-class (name class-of-function &rest options)
X  (check-type name symbol "a symbol which is the name of a meta-class")
X  (check-type class-of-function function "a function")
X  `(load-define-meta-class ',name ',class-of-function))
X
X(defun load-define-meta-class (name class-of-function)
X  (or (eq name 'class)
X      (class-named name t)
X      (error "In define-meta-class, there is no class named ~S.~%~
X              The class ~S must be defined before evaluating this~%~
X              define-meta-class form."))
X  (let ((existing (assq name *meta-classes*)))
X    (if existing
X    (setf (cdr existing) class-of-function)
X    (setq *meta-classes* (nconc *meta-classes*
X                    (list (cons name class-of-function)))))
X    (recompile-class-of)))
X
X(defun recompile-class-of ()
X    ;; Change the definition of class-of so that the next time it is
X    ;; called it will recompile itself.
X    ;; NOTE:  This does not have to be written this way.  If we impose
X    ;;        the constraint that any define-meta-class must be loaded
X    ;;        in the same environment as it was compiled then there is
X    ;;        no need for a compiler at run or load time.
X    ;;        By same environment I mean with the same define-meta-class
X    ;;        forms already in force, and this certainly seems like a
X    ;;        reasonable constraint to me.
X    (setf (symbol-function 'class-of)
X      #'(lambda (x)
X          (declare (notinline class-of))
X          ;; Now recompile class-of so that the new definition
X          ;; of %instance-class-of will take effect.
X          (compile 'class-of *class-of*)
X          (class-of x))))
X
X  ;;
X;;;;;; TYPEP and TYPE-OF support.
X  ;;
X;;; Portable CommonLoops makes no changes to typep or type-of.  In order for
X;;; those functions to work with CommonLoops objects each implementation will
X;;; have to fix its typep and type-of.  It shouldn't be hard though, and
X;;; these macros should help.
X
X(defmacro %instance-typep (x type)
X  `(not (null (memq (class-named ,type ())
X                    (class-class-precedence-list (class-of ,x))))))
X
X(defmacro %instance-type-of (x)
X  `(class-name (class-of ,x)))
X
X  ;;
X;;;;;; The primitive instances.
X  ;;
X;;;
X;;; Conceptually, a %instance is an array-like datatype whose first element
X;;; points to the meta-class of the %instance and whose remaining elements
X;;; are used by the meta-class for whatever purpose it wants.
X;;;
X;;; What would like to do is use defstruct to define a new type with a
X;;; variable number of slots.  Unfortunately, Common Lisp itself does not
X;;; let us do that.  So we have to define a new type %instance, and have
X;;; it point to an array which is the extra slots.
X;;;
X;;; Most any port of PCL should re-implement this datatype.  Implementing it
X;;; as a variable length type so that %instance are only one vector in memory
X;;; (the "extra slots" are in-line with the meta-class) will have significant
X;;; impact on the speed of many CommonLoops programs.  As an example of how
X;;; to do this re-implementation of %instance, please see the file 3600-low.
X;;;
X
X(defstruct (%instance (:print-function print-instance)
X              (:constructor %make-instance-1 (meta-class storage))
X              (:predicate %instancep))
X  meta-class
X  storage)
X
X(defmacro %make-instance (meta-class size)
X  `(%make-instance-1 ,meta-class (make-array ,size)))
X
X(defmacro %instance-ref (instance index)
X  `(aref (%instance-storage ,instance) ,index))
X
X(defun print-instance (instance stream depth) ;This is a temporary definition
X  (ignore depth)                  ;used mostly for debugging the
X  (printing-random-thing (instance stream)    ;bootstrapping code.
X    (format stream "instance ??")))
X
X  ;;
X;;;;;;  Very Low-Level representation of instances with meta-class class.
X  ;;
X;;; As shown below, an instance with meta-class class (iwmc-class) is a three
X;;; *slot* structure.
X;;;
X;;;
X;;;                                             /------["Class"]
X;;;                  /-------["Class Wrapper"  /  <slot-and-method-cache>]
X;;;                 /
X;;;  Instance--> [ / , \  ,  \ ]
X;;;                     \     \
X;;;                      \     \---[Instance Slot Storage Block]
X;;;                       \
X;;;                        \-------[Dynamic Slot plist]
X;;;
X;;; Instances with meta-class class point to their class indirectly through
X;;; the class's class wrapper (each class has one class wrapper, not each
X;;; instance).  This is done so that all the extant instances of a class can
X;;; have the class they point to changed quickly.  See change-class.
X;;;
X;;; Static-slots are a 1-d-array-like structure.
X;;; The default PCL implementation is as a memory block as described above.
X;;; Particular ports are free to change this to a lower-level block of memory
X;;; type structure. Once again, the accessor for static-slots storage doesn't
X;;; need to do bounds checking, and static-slots structures don't need to be
X;;; able to change size.  This is because new slots are added using the
X;;; dynamic slot mechanism, and if the class changes or the class of the
X;;; instance changes a new static-slot structure is allocated (if needed).
X;;
X;;; Dynamic-slots are a plist-like structure.
X;;; The default PCL implementation is as a plist.
X;;;
X;;; *** Put a real discussion here of where things should be consed.
X;;;  - if all the class wrappers in the world are on the same page that
X;;;    would be good because during method lookup we only use the wrappers
X;;;    not the classes and once a slot is cached, we only use the wrappers
X;;;    too.  So a page of just wrappers would stay around all the time and
X;;;    you would never have to page in the classes at least in "tight" loops.
X;;;
X
X(defmacro iwmc-class-p (x)
X  `(and (%instancep ,x)
X    (eq (%instance-meta-class ,x)
X        (load-time-eval (class-named 'class)))))
X
X;(defmacro %allocate-iwmc-class ()
X;  `(%make-instance (load-time-eval (class-named 'class)) 3))
X
X(defmacro iwmc-class-class-wrapper (iwmc-class)
X  `(%instance-ref ,iwmc-class 0))
X
X(defmacro iwmc-class-static-slots (iwmc-class)
X  `(%instance-ref ,iwmc-class 1))
X
X(defmacro iwmc-class-dynamic-slots (iwmc-class)
X  `(%instance-ref ,iwmc-class 2))
X
X
X(defmacro %allocate-instance--class (no-of-slots &optional class-class)
X  `(let ((iwmc-class
X       (%make-instance ,(or class-class
X                '(load-time-eval (class-named 'class)))
X               3)))
X     (%allocate-instance--class-1 ,no-of-slots iwmc-class)
X     iwmc-class))
X
X(defmacro %allocate-instance--class-1 (no-of-slots instance)
X  (once-only (instance)
X    `(progn
X       (setf (iwmc-class-static-slots ,instance)
X         (%allocate-static-slot-storage--class ,no-of-slots))
X       (setf (iwmc-class-dynamic-slots ,instance)
X         (%allocate-dynamic-slot-storage--class)))))
X
X
X(defmacro %allocate-class-class (no-of-slots)    ;This is used to allocate the
X  `(let ((i (%make-instance nil 3)))        ;class class.  It bootstraps
X     (setf (%instance-meta-class i) i)        ;the call to class-named in
X     (setf (class-named 'class) i)        ;%allocate-instance--class.
X     (%allocate-instance--class-1 ,no-of-slots i)
X     i))
X
X(defmacro %convert-slotd-position-to-slot-index (slotd-position)
X  slotd-position)
X
X
X(defmacro %allocate-static-slot-storage--class (no-of-slots)
X  `(make-memory-block ,no-of-slots))
X
X(defmacro %static-slot-storage-get-slot--class (static-slot-storage
X                        slot-index)
X  `(memory-block-ref ,static-slot-storage ,slot-index))
X
X(defmacro %allocate-dynamic-slot-storage--class ()
X  ())
X
X(defmacro %dynamic-slot-storage-get-slot--class (dynamic-slot-storage
X                         name
X                         default)
X  `(getf ,dynamic-slot-storage ,name ,default))
X
X(defmacro %dynamic-slot-storage-remove-slot--class (dynamic-slot-storage
X                            name)
X  `(remf ,dynamic-slot-storage ,name))
X
X
X
X(defmacro class-of--class (iwmc-class)
X  `(class-wrapper-class (iwmc-class-class-wrapper ,iwmc-class)))
X
X(define-meta-class class (lambda (x) (class-of--class x)))
X
X
X  ;;
X;;;;;; Class Wrappers  (the Watercourse Way algorithm)
X  ;;
X;;; Well, we had this really cool scheme for keeping multiple different
X;;; caches tables in the same block of memory.  Unfortunately, we only
X;;; cache one thing in class wrappers these days, and soon class wrappers
X;;; will go away entirely so its kind of lost generality.  I am leaving
X;;; the old comment here cause the hack is worth remembering.
X;;;
X;;; * Old Comment
X;;; * The key point are:
X;;; *
X;;; *  - No value in the cache can be a key for anything else stored
X;;; *    in the cache.
X;;; *
X;;; *  - When we invalidate a wrapper cache, we flush it so that when
X;;; *    it is next touched it will get a miss.
X;;; *
X;;; * A class wrapper is a block of memory whose first two slots have a
X;;; * deadicated (I just can't help myself) purpose and whose remaining
X;;; * slots are the shared cache table.  A class wrapper looks like:
X;;; *
X;;; *  slot 0:   <pointer to class>
X;;; *  slot 1:   T if wrapper is valid, NIL otherwise.
X;;; *   .
X;;; *   .          shared cache
X;;; *   .
X;;;
X
X(eval-when (compile load eval)
X
X(defconstant class-wrapper-cache-size 32
X  "The size of class-wrapper caches.")
X
X(defconstant class-wrapper-leader 2
X  "The number of slots at the beginning of a class wrapper which have a
X   special purpose.  These are the slots that are not part of the cache.")
X
X; due to a compiler bug, the extra "2" default argument has been added
X; to the following function invocation, for HP Lisp. rds 3/6/87
X(defconstant class-wrapper-cache-mask
X         (make-memory-block-mask class-wrapper-cache-size 2))
X
X)
X
X(defmacro make-class-wrapper (class)
X  `(let ((wrapper (make-memory-block ,(+ class-wrapper-cache-size
X                     class-wrapper-leader)
X                     class-wrapper-area)))
X     (setf (class-wrapper-class wrapper) ,class)
X     (setf (class-wrapper-valid-p wrapper) t)
X     wrapper))
X
X(defmacro class-wrapper-class (class-wrapper)
X  `(memory-block-ref ,class-wrapper 0))
X
X(defmacro class-wrapper-valid-p (class-wrapper)
X  `(memory-block-ref ,class-wrapper 1))
X
X(defmacro class-wrapper-cached-key (class-wrapper offset)
X  `(memory-block-ref ,class-wrapper ,offset))
X
X(defmacro class-wrapper-cached-val (class-wrapper offset)
X  `(memory-block-ref ,class-wrapper (+ ,offset 1)))
X
X(defmacro class-wrapper-get-slot-offset (class-wrapper slot-name)
X  (ignore class-wrapper)
X  `(+ class-wrapper-leader
X      0
X      (symbol-cache-no ,slot-name ,class-wrapper-cache-mask)))
X
X
X(defmacro flush-class-wrapper-cache (class-wrapper)
X  `(clear-memory-block ,class-wrapper
X               ,class-wrapper-leader
X               ,class-wrapper-cache-size))
X
X(defmacro class-wrapper-cache-cache-entry (wrapper offset key val)
X  (once-only (wrapper offset key val)
X    `(without-interrupts
X       (setf (class-wrapper-cached-key ,wrapper ,offset) ,key)     ;store key
X       (setf (class-wrapper-cached-val ,wrapper ,offset) ,val))));store value
X
X(defmacro class-wrapper-cache-cached-entry (wrapper offset key)
X  (once-only (wrapper offset)
X    `(and (eq (class-wrapper-cached-key ,wrapper ,offset) ,key)
X      (class-wrapper-cached-val ,wrapper ,offset))))
X
X(defmacro invalidate-class-wrapper (wrapper)
X  (once-only (wrapper)
X    `(progn (flush-class-wrapper-cache ,wrapper)
X        (setf (class-wrapper-valid-p ,wrapper) nil))))
X
X(defmacro validate-class-wrapper (iwmc-class)              ;HAS to be a macro!
X  `(let ((wrapper (iwmc-class-class-wrapper ,iwmc-class)));So that xxx-low
X     (if (class-wrapper-valid-p wrapper)              ;can redefine the
X     wrapper                          ;macros we use.
X     (progn (setf (iwmc-class-class-wrapper ,iwmc-class)
X              (class-wrapper (class-wrapper-class wrapper)))
X        (setf (class-wrapper-valid-p wrapper) t)))))
X
X  ;;
X;;;;;; Generating CACHE numbers
X  ;;
X;;; These macros should produce a CACHE number for their first argument
X;;; masked to fit in their second argument.  A useful cache number is just
X;;; the symbol or object's memory address.  The memory address can either
X;;; be masked to fit the mask or folded down with xor to fit in the mask.
X;;; See some of the other low files for examples of how to implement these
X;;; macros. Except for their illustrative value, the portable versions of
X;;; these macros are nearly worthless.  Any port of CommonLoops really
X;;; should redefine these to be faster and produce more useful numbers.
X
X(defvar *warned-about-symbol-cache-no* nil)
X(defvar *warned-about-object-cache-no* nil)
X
X(defmacro symbol-cache-no (symbol mask)
X  (unless *warned-about-symbol-cache-no*
X    (setq *warned-about-symbol-cache-no* t)
X    (warn
X      "Compiling PCL without having defined an implementation-specific~%~
X       version of SYMBOL-CACHE-NO.  This is likely to have a significant~%~
X       effect on slot-access performance.~%~
X       See the definition of symbol-cache-no in the file low to get an~%~
X       idea of how to implement symbol-cache-no."))
X  `(logand (sxhash ,symbol) ,mask))
X
X(defmacro object-cache-no (object mask)
X  (ignore object)
X  (unless *warned-about-object-cache-no*
X    (setq *warned-about-object-cache-no* t)
X    (warn
X      "Compiling PCL without having defined an implementation-specific~%~
X       version of OBJECT-CACHE-NO.  This effectively disables method.~%~
X       lookup caching.  See the definition of object-cache-no in the file~%~
X       low to get an idea of how to implement object-cache-no."))
X  `(logand 0 ,mask))
X
X
X  ;;
X;;;;;; FUNCTION-ARGLIST
X  ;;
X;;; Given something which is functionp, function-arglist should return the
X;;; argument list for it.  PCL does not count on having this available, but
X;;; MAKE-SPECIALIZABLE works much better if it is available.  Versions of
X;;; function-arglist for each specific port of pcl should be put in the
X;;; appropriate xxx-low file. This is what it should look like:
X;(defun function-arglist (function)
X;  (<system-dependent-arglist-function> function))
X
X(defun function-pretty-arglist (function)
X  (ignore function)
X  ())
X
X(defsetf function-pretty-arglist set-function-pretty-arglist)
X
X(defun set-function-pretty-arglist (function new-value)
X  (ignore function)
X  new-value)
X
X
X
X  ;;
X;;;;;; Templated functions
X  ;;
X;;; In CommonLoops there are many program-generated functions which
X;;; differ from other, similar program-generated functions only in the
X;;; values of certain in-line constants.
X;;;
X;;; A prototypical example is the family of discriminating functions used by
X;;; classical discriminators.  For all classical discriminators which have
X;;; the same number of required arguments and no &rest argument, the
X;;; discriminating function is the same, except for the value of the
X;;; "in-line" constants (the cache and discriminator).
X;;;
X;;; Naively, whenever we want one of these functions we have to produce and
X;;; compile separate lambda. But this is very expensive, instead what we
X;;; would like to do is copy the existing compiled code and replace the
X;;; values of the inline constants with the right new values.
X;;;
X;;; Templated functions provide a nice interface to this abstraction of
X;;; copying an existing compiled function and replacing certain constants
X;;; with others.  Templated functions are based on the assumption that for
X;;; any given CommonLisp one of the following is true:
X;;;   Either:
X;;;     Funcalling a lexical closure is fast, and lexical variable access
X;;;     is as fast (or about as fast) in-line constant access.  In this
X;;;     case we implement templated functions as lexical closures closed
X;;;     over the constants we want to change from one instance of the
X;;;     templated function to another.
X;;;   Or:
X;;;     Code can be written to take a compiled code object, copy it and
X;;;     replace references to certain in-line constants with references
X;;;     to other in-line constants.
X;;;
X;;; Actually, I believe that for most Lisp both of the above assumptions are
X;;; true.  For certain lisps the explicit copy and replace scheme *may be*
X;;; more efficient but the lexical closure scheme is completely portable and
X;;; is likely to be more efficient since the lexical closure it returns are
X;;; likely to share compiled code objects and only have separate lexical
X;;; environments.
X;;;
X;;; Another thing to notice about templated functions is that they provide
X;;; the modularity to support special objects which a particular
X;;; implementation's low-level function-calling code might know about.   As
X;;; an example, when a classical discriminating function is created, the
X;;; code says "make a classical discriminating function with 1 required
X;;; arguments". It then uses whatever comes back from the templated function
X;;; code as the the discriminating function So, a particular port can easily
X;;; make this return any sort of special data structure instead of one of
X;;; the lexical closures the portable implementation returns.
X;;;
X(defvar *templated-function-types* ())
X(defmacro define-function-template (name
X                    template-parameters
X                    instance-parameters
X                    &body body)
X  `(progn
X     (pushnew ',name *templated-function-types*)
X     ;; Get rid of all the cached constructors.
X     (setf (get ',name 'templated-fn-constructors) ())
X     ;; Now define the constructor constructor.
X     (setf (get ',name 'templated-fn-params)
X       (list* ',template-parameters ',instance-parameters ',body))
X     (setf (get ',name 'templated-fn-constructor-constructor)
X       ,(make-templated-function-constructor-constructor
X          template-parameters instance-parameters body))))
X
X(defun reset-templated-function-types ()
X  (dolist (type *templated-function-types*)
X    (setf (get type 'templated-fn-constructors) ())))
X
X(defun get-templated-function-constructor (name &rest template-parameters)
X  (setq template-parameters (copy-list template-parameters)) ;Groan.
X  (let ((existing (assoc template-parameters
X             (get name 'templated-fn-constructors)
X             :test #'equal)))
X    (if existing
X    (progn (setf (nth 3 existing) t)    ;Mark this constructor as
X                        ;having been used.
X           (cadr existing))            ;And return the actual
X                        ;constructor.
X    (let ((new-constructor
X        (apply (get name 'templated-fn-constructor-constructor)
X               template-parameters)))
X      (push (list template-parameters new-constructor 'made-on-the-fly t)
X        (get name 'templated-fn-constructors))
X      new-constructor))))
X
X(defmacro pre-make-templated-function-constructor (name
X                           &rest template-parameters)
X  (setq template-parameters (copy-list template-parameters))    ;Groan.
X  (let* ((params (get name 'templated-fn-params))
X     (template-params (car params))
X     (instance-params (cadr params))
X     (body (cddr params))
X     (dummy-fn-name (gensym)))   ;For the 3600, which doesn't bother to
X                     ;compile top-level forms, we do the
X                     ;top-level form compilation by hand.
X    (progv template-params
X       template-parameters
X      `(progn
X     (defun ,dummy-fn-name ()
X       (let ((entry
X           (or (assoc ',template-parameters
X                  (get ',name 'templated-fn-constructors)
X                  :test #'equal)
X               (let ((new-entry
X                   (list ',template-parameters () () ())))
X             (push new-entry
X                   (get ',name 'templated-fn-constructors))
X             new-entry))))
X         (setf (caddr entry) 'pre-made)
X         (setf (cadr entry)
X           (function (lambda ,(eval instance-params)
X                   ,(eval (cons 'progn body)))))))
X     (,dummy-fn-name)))))
X
X(defun make-templated-function-constructor-constructor (template-params
X                            instance-params
X                            body)
X  `(function
X     (lambda ,template-params
X       (compile () (list 'lambda ,instance-params ,@body)))))
X
X  ;;
X;;;;;;
X  ;;
X
X(defun record-definition (name type &rest args)
X  (ignore name type args)
X  ())
X
X(defun compile-time-define (&rest ignore)
X  (ignore ignore))
X
END_OF_FILE
if test 27849 -ne `wc -c <'low.l'`; then
    echo shar: \"'low.l'\" unpacked with wrong size!
fi
# end of 'low.l'
fi
echo shar: End of archive 8 \(of 13\).
cp /dev/null ark8isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]